home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Tcl-Tk 8.0 / Pre-installed version / tcl8.0 / tests / defs < prev    next >
Encoding:
Text File  |  1997-08-15  |  13.7 KB  |  448 lines  |  [TEXT/ALFA]
  1. # This file contains support code for the Tcl test suite.  It is
  2. # normally sourced by the individual files in the test suite before
  3. # they run their tests.  This improved approach to testing was designed
  4. # and initially implemented by Mary Ann May-Pumphrey of Sun Microsystems.
  5. #
  6. # Copyright (c) 1990-1994 The Regents of the University of California.
  7. # Copyright (c) 1994-1996 Sun Microsystems, Inc.
  8. #
  9. # See the file "license.terms" for information on usage and redistribution
  10. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  11. #
  12. # SCCS: @(#) defs 1.60 97/08/13 18:10:19
  13.  
  14. if ![info exists VERBOSE] {
  15.     set VERBOSE 0
  16. }
  17. if ![info exists TESTS] {
  18.     set TESTS {}
  19. }
  20.  
  21. # If tests are being run as root, issue a warning message and set a
  22. # variable to prevent some tests from running at all.
  23.  
  24. set user {}
  25. if {$tcl_platform(platform) == "unix"} {
  26.     catch {set user [exec whoami]}
  27.     if {$user == ""} {
  28.         catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user}
  29.     }
  30.     if {$user == ""} {set user root}
  31.     if {$user == "root"} {
  32.         puts stdout "Warning: you're executing as root.  I'll have to"
  33.         puts stdout "skip some of the tests, since they'll fail as root."
  34.     set testConfig(root) 1
  35.     }
  36. }
  37.  
  38. # Some of the tests don't work on some system configurations due to
  39. # differences in word length, file system configuration, etc.  In order
  40. # to prevent false alarms, these tests are generally only run in the
  41. # master development directory for Tcl.  The presence of a file
  42. # "doAllTests" in this directory is used to indicate that the non-portable
  43. # tests should be run.
  44.  
  45. # If there is no "memory" command (because memory debugging isn't
  46. # enabled), generate a dummy command that does nothing.
  47.  
  48. if {[info commands memory] == ""} {
  49.     proc memory args {}
  50. }
  51.  
  52. # Check configuration information that will determine which tests
  53. # to run.  To do this, create an array testConfig.  Each element
  54. # has a 0 or 1 value, and the following elements are defined:
  55. #    unixOnly -    1 means this is a UNIX platform, so it's OK
  56. #            to run tests that only work under UNIX.
  57. #    macOnly -    1 means this is a Mac platform, so it's OK
  58. #            to run tests that only work on Macs.
  59. #    pcOnly -    1 means this is a PC platform, so it's OK to
  60. #            run tests that only work on PCs.
  61. #    unixOrPc -    1 means this is a UNIX or PC platform.
  62. #    macOrPc -    1 means this is a Mac or PC platform.
  63. #    macOrUnix -    1 means this is a Mac or UNIX platform.
  64. #    nonPortable -    1 means this the tests are being running in
  65. #            the master Tcl/Tk development environment;
  66. #            Some tests are inherently non-portable because
  67. #            they depend on things like word length, file system
  68. #            configuration, window manager, etc.  These tests
  69. #            are only run in the main Tcl development directory
  70. #            where the configuration is well known.  The presence
  71. #            of the file "doAllTests" in this directory indicates
  72. #            that it is safe to run non-portable tests.
  73. #       knownBug -      The test is known to fail and the bug is not yet
  74. #                       fixed. The test will be run only if the file
  75. #                       "doBuggyTests" exists (intended for Tcl dev. group
  76. #                       internal use only).
  77. #    tempNotPc -    The inverse of pcOnly.  This flag is used to
  78. #            temporarily disable a test.
  79. #    tempNotMac -    The inverse of macOnly.  This flag is used to
  80. #            temporarily disable a test.
  81. #    nonBlockFiles - 1 means this platform supports setting files into
  82. #            nonblocking mode.
  83. #    asyncPipeClose- 1 means this platform supports async flush and
  84. #            async close on a pipe.
  85. #    unixExecs     - 1 means this machine has commands such as 'cat',
  86. #            'echo' etc available.
  87. #    notIfCompiled -    1 means this that it is safe to run tests that
  88. #                       might fail if the bytecode compiler is used. This
  89. #                       element is set 1 if the file "doAllTests" exists in
  90. #                       this directory. Normally, this element is 0 so that
  91. #                       tests that fail with the bytecode compiler are
  92. #            skipped. As of 11/2/96 these are the history tests
  93. #            since they depend on accurate source location
  94. #            information.
  95.  
  96. catch {unset testConfig}
  97. if {$tcl_platform(platform) == "unix"} {
  98.     set testConfig(unixOnly) 1
  99.     set testConfig(tempNotPc) 1
  100.     set testConfig(tempNotMac) 1
  101. } else {
  102.     set testConfig(unixOnly) 0
  103. } 
  104. if {$tcl_platform(platform) == "macintosh"} {
  105.     set testConfig(tempNotPc) 1
  106.     set testConfig(macOnly) 1
  107. } else {
  108.     set testConfig(macOnly) 0
  109. } 
  110. if {$tcl_platform(platform) == "windows"} {
  111.     set testConfig(tempNotMac) 1
  112.     set testConfig(pcOnly) 1
  113. } else {
  114.     set testConfig(pcOnly) 0
  115. }
  116. set testConfig(unixOrPc) [expr $testConfig(unixOnly) || $testConfig(pcOnly)]
  117. set testConfig(macOrPc) [expr $testConfig(macOnly) || $testConfig(pcOnly)]
  118. set testConfig(macOrUnix) [expr $testConfig(macOnly) || $testConfig(unixOnly)]
  119. set testConfig(nonPortable)    [expr [file exists doAllTests] || [file exists doAllTe]]
  120. set testConfig(knownBug) [expr [file exists doBuggyTests] || [file exists doBuggyT]]
  121. set testConfig(notIfCompiled) [file exists doAllCompilerTests]
  122.  
  123. set testConfig(unix)    $testConfig(unixOnly)
  124. set testConfig(mac)    $testConfig(macOnly)
  125. set testConfig(pc)    $testConfig(pcOnly)
  126.  
  127. set testConfig(nt)    [expr {$tcl_platform(os) == "Windows NT"}]
  128. set testConfig(95)    [expr {$tcl_platform(os) == "Windows 95"}]
  129. set testConfig(win32s)    [expr {$tcl_platform(os) == "Win32s"}]
  130.  
  131. # The following config switches are used to mark tests that crash on
  132. # certain platforms, so that they can be reactivated again when the
  133. # underlying problem is fixed.
  134.  
  135. set testConfig(pcCrash) $testConfig(macOrUnix)
  136. set testConfig(macCrash) $testConfig(unixOrPc)
  137. set testConfig(unixCrash) $testConfig(macOrPc)
  138.  
  139. if {[catch {set f [open defs r]}]} {
  140.     set testConfig(nonBlockFiles) 1
  141. } else {
  142.     if {[expr [catch {fconfigure $f -blocking off}]] == 0} {
  143.     set testConfig(nonBlockFiles) 1
  144.     } else {
  145.     set testConfig(nonBlockFiles) 0
  146.     }
  147.     close $f
  148. }
  149.  
  150. trace variable testConfig r safeFetch
  151.  
  152. proc safeFetch {n1 n2 op} {
  153.     global testConfig 
  154.  
  155.     if {($n2 != {}) && ([info exists testConfig($n2)] == 0)} {
  156.     set testConfig($n2) 0
  157.     }
  158. }
  159.  
  160. # Test for SCO Unix - cannot run async flushing tests because a potential
  161. # problem with select is apparently interfering. (Mark Diekhans).
  162.  
  163. if {$tcl_platform(platform) == "unix"} {
  164.     if {[catch {exec uname -X | fgrep {Release = 3.2v}}] == 0} {
  165.     set testConfig(asyncPipeClose) 0
  166.     } else {
  167.     set testConfig(asyncPipeClose) 1
  168.     }
  169. } else {
  170.     set testConfig(asyncPipeClose) 1
  171. }
  172.  
  173. # Test to see if execed commands such as cat, echo, rm and so forth are
  174. # present on this machine.
  175.  
  176. set testConfig(unixExecs) 1
  177. if {$tcl_platform(platform) == "macintosh"} {
  178.     set testConfig(unixExecs) 0
  179. }
  180. if {($testConfig(unixExecs) == 1) && ($tcl_platform(platform) == "windows")} {
  181.     if {[catch {exec cat defs}] == 1} {
  182.     set testConfig(unixExecs) 0
  183.     }
  184.     if {($testConfig(unixExecs) == 1) && ([catch {exec echo hello}] == 1)} {
  185.     set testConfig(unixExecs) 0
  186.     }
  187.     if {($testConfig(unixExecs) == 1) && \
  188.         ([catch {exec sh -c echo hello}] == 1)} {
  189.     set testConfig(unixExecs) 0
  190.     }
  191.     if {($testConfig(unixExecs) == 1) && ([catch {exec wc defs}] == 1)} {
  192.     set testConfig(unixExecs) 0
  193.     }
  194.     if {$testConfig(unixExecs) == 1} {
  195.     exec echo hello > removeMe
  196.         if {[catch {exec rm removeMe}] == 1} {
  197.         set testConfig(unixExecs) 0
  198.     }
  199.     }
  200.     if {($testConfig(unixExecs) == 1) && ([catch {exec sleep 1}] == 1)} {
  201.     set testConfig(unixExecs) 0
  202.     }
  203.     if {($testConfig(unixExecs) == 1) && \
  204.         ([catch {exec fgrep unixExecs defs}] == 1)} {
  205.     set testConfig(unixExecs) 0
  206.     }
  207.     if {($testConfig(unixExecs) == 1) && ([catch {exec ps}] == 1)} {
  208.     set testConfig(unixExecs) 0
  209.     }
  210.     if {($testConfig(unixExecs) == 1) && \
  211.         ([catch {exec echo abc > removeMe}] == 0) && \
  212.         ([catch {exec chmod 644 removeMe}] == 1) && \
  213.         ([catch {exec rm removeMe}] == 0)} {
  214.     set testConfig(unixExecs) 0
  215.     } else {
  216.     catch {exec rm -f removeMe}
  217.     }
  218.     if {($testConfig(unixExecs) == 1) && \
  219.         ([catch {exec mkdir removeMe}] == 1)} {
  220.     set testConfig(unixExecs) 0
  221.     } else {
  222.     catch {exec rm -r removeMe}
  223.     }
  224.     if {$testConfig(unixExecs) == 0} {
  225.     puts stdout "Warning: Unix-style executables are not available, so"
  226.     puts stdout "some tests will be skipped."
  227.     }
  228. }    
  229.  
  230. proc print_verbose {name description constraints script code answer} {
  231.     puts stdout "\n"
  232.     if {[string length $constraints]} {
  233.     puts stdout "==== $name $description\t--- ($constraints) ---"
  234.     } else {
  235.     puts stdout "==== $name $description"
  236.     }
  237.     puts stdout "==== Contents of test case:"
  238.     puts stdout "$script"
  239.     if {$code != 0} {
  240.     if {$code == 1} {
  241.         puts stdout "==== Test generated error:"
  242.         puts stdout $answer
  243.     } elseif {$code == 2} {
  244.         puts stdout "==== Test generated return exception;  result was:"
  245.         puts stdout $answer
  246.     } elseif {$code == 3} {
  247.         puts stdout "==== Test generated break exception"
  248.     } elseif {$code == 4} {
  249.         puts stdout "==== Test generated continue exception"
  250.     } else {
  251.         puts stdout "==== Test generated exception $code;  message was:"
  252.         puts stdout $answer
  253.     }
  254.     } else {
  255.     puts stdout "==== Result was:"
  256.     puts stdout "$answer"
  257.     }
  258. }
  259.  
  260. # test --
  261. # This procedure runs a test and prints an error message if the
  262. # test fails.  If VERBOSE has been set, it also prints a message
  263. # even if the test succeeds.  The test will be skipped if it
  264. # doesn't match the TESTS variable, or if one of the elements
  265. # of "constraints" turns out not to be true.
  266. #
  267. # Arguments:
  268. # name -        Name of test, in the form foo-1.2.
  269. # description -        Short textual description of the test, to
  270. #            help humans understand what it does.
  271. # constraints -        A list of one or more keywords, each of
  272. #            which must be the name of an element in
  273. #            the array "testConfig".  If any of these
  274. #            elements is zero, the test is skipped.
  275. #            This argument may be omitted.
  276. # script -        Script to run to carry out the test.  It must
  277. #            return a result that can be checked for
  278. #            correctness.
  279. # answer -        Expected result from script.
  280.  
  281. proc test {name description script answer args} {
  282.     global VERBOSE TESTS testConfig
  283.     if {[string compare $TESTS ""] != 0} then {
  284.     set ok 0
  285.     foreach test $TESTS {
  286.         if [string match $test $name] then {
  287.         set ok 1
  288.         break
  289.         }
  290.         }
  291.     if !$ok then return
  292.     }
  293.     set i [llength $args]
  294.     if {$i == 0} {
  295.     set constraints {}
  296.     } elseif {$i == 1} {
  297.     # "constraints" argument exists;  shuffle arguments down, then
  298.     # make sure that the constraints are satisfied.
  299.  
  300.     set constraints $script
  301.     set script $answer
  302.     set answer [lindex $args 0]
  303.     set doTest 0
  304.     if {[string match {*[$\[]*} $constraints] != 0} {
  305.         # full expression, e.g. {$foo > [info tclversion]}
  306.  
  307.         catch {set doTest [uplevel #0 expr [list $constraints]]} msg
  308.     } elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} {
  309.         # something like {a || b} should be turned into 
  310.         # $testConfig(a) || $testConfig(b).
  311.  
  312.          regsub -all {[.a-zA-Z0-9]+} $constraints {$testConfig(&)} c
  313.         catch {set doTest [eval expr $c]}
  314.     } else {
  315.         # just simple constraints such as {unixOnly fonts}.
  316.  
  317.         set doTest 1
  318.         foreach constraint $constraints {
  319.         if {![info exists testConfig($constraint)]
  320.             || !$testConfig($constraint)} {
  321.             set doTest 0
  322.             break
  323.         }
  324.         }
  325.     }
  326.     if {$doTest == 0} {
  327.         if $VERBOSE then {
  328.         puts stdout "++++ $name SKIPPED: $constraints"
  329.         }
  330.         return    
  331.     }
  332.     } else {
  333.     error "wrong # args: must be \"test name description ?constraints? script answer\""
  334.     }
  335.     memory tag $name
  336.     set code [catch {uplevel $script} result]
  337.     if {$code != 0} {
  338.     print_verbose $name $description $constraints $script \
  339.         $code $result
  340.     } elseif {[string compare $result $answer] == 0} then { 
  341.     if $VERBOSE then {
  342.         if {$VERBOSE > 0} {
  343.         print_verbose $name $description $constraints $script \
  344.             $code $result
  345.         }
  346.         if {$VERBOSE != -2} {
  347.         puts stdout "++++ $name PASSED"
  348.         }
  349.     }
  350.     } else { 
  351.     print_verbose $name $description $constraints $script \
  352.         $code $result
  353.     puts stdout "---- Result should have been:"
  354.     puts stdout "$answer"
  355.     puts stdout "---- $name FAILED" 
  356.     }
  357. }
  358.  
  359. proc dotests {file args} {
  360.     global TESTS
  361.     set savedTests $TESTS
  362.     set TESTS $args
  363.     source $file
  364.     set TESTS $savedTests
  365. }
  366.  
  367. proc normalizeMsg {msg} {
  368.     regsub "\n$" [string tolower $msg] "" msg
  369.     regsub -all "\n\n" $msg "\n" msg
  370.     regsub -all "\n\}" $msg "\}" msg
  371.     return $msg
  372. }
  373.  
  374. proc makeFile {contents name} {
  375.     set fd [open $name w]
  376.     fconfigure $fd -translation lf
  377.     if {[string index $contents [expr [string length $contents] - 1]] == "\n"} {
  378.     puts -nonewline $fd $contents
  379.     } else {
  380.     puts $fd $contents
  381.     }
  382.     close $fd
  383. }
  384.  
  385. proc removeFile {name} {
  386.     file delete $name
  387. }
  388.  
  389. proc makeDirectory {name} {
  390.     file mkdir $name
  391. }
  392.  
  393. proc removeDirectory {name} {
  394.     file delete -force $name
  395. }
  396.  
  397. proc viewFile {name} {
  398.     global tcl_platform testConfig
  399.     if {($tcl_platform(platform) == "macintosh") || \
  400.         ($testConfig(unixExecs) == 0)} {
  401.     set f [open $name]
  402.     set data [read -nonewline $f]
  403.     close $f
  404.     return $data
  405.     } else {
  406.     exec cat $name
  407.     }
  408. }
  409.  
  410. # Locate tcltest executable
  411.  
  412. set tcltest [info nameofexecutable]
  413.  
  414. if {$tcltest == "{}"} {
  415.     set tcltest {}
  416.     puts "Unable to find tcltest executable, multiple process tests will fail."
  417. }
  418.  
  419. if {$tcl_platform(os) != "Win32s"} {
  420.     # Don't even try running another copy of tcltest under win32s, or you 
  421.     # get an error dialog about multiple instances.
  422.  
  423.     catch {
  424.     file delete -force tmp
  425.     set f [open tmp w]
  426.     puts $f {
  427.         exit
  428.     }
  429.     close $f
  430.     set f [open "|[list $tcltest tmp]" r]
  431.     close $f
  432.     set testConfig(stdio) 1
  433.     }
  434. }
  435.  
  436. if {($tcl_platform(platform) == "windows") && ($testConfig(stdio) == 0)} {
  437.     puts "(will skip tests that redirect stdio of exec'd 32-bit applications)"
  438. }
  439.  
  440. catch {socket} msg
  441. set testConfig(socket) [expr {$msg != "sockets are not available on this system"}]
  442.  
  443. if {$testConfig(socket) == 0} {
  444.     puts "(will skip tests that use sockets)"
  445. }
  446.     
  447.         
  448.